home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 September / Macworld (1997-09).dmg / Shareware World / Utilities / Text Processing / AlphaLite.6.52 / Tcl / SystemCode / sendURL.tcl < prev    next >
Text File  |  1997-03-27  |  1KB  |  41 lines
  1. # (WTP 7/30/95) Slightly improved 'sendURL'.
  2. # By accepting a text arg, this can now be used to make sendURL 
  3. # hypertext links (useful for "mailto" links in documentation, f'rinstance) 
  4. #===============================================================================
  5. set htmlEventSuiteIDs(MOSS) {WWW!}
  6. set htmlEventSuiteIDs(MSIE) {WWW!}
  7.  
  8. proc sendUrl {{text {}}} {
  9.         if {$text == {}} { set text [getSelect] }
  10.         if {$text == {}} { set text [prompt {URL?} {}] }
  11.          if {[string length $text] == 0} { return }
  12.  
  13.         global htmlEventSuiteIDs browserSig
  14.  
  15.         if {[catch {launchBackApplSigs {MOSS} browserSig}]} {
  16.             getApplSig "Please locate your web browser:" browserSig
  17.         }
  18.         set name [file tail [launchBackAppl $browserSig]]
  19.  
  20.         if {![info exists htmlEventSuiteIDs($browserSig)]} {
  21.                 alertnote "Can't send URLs to this HTML browser"
  22.                 return
  23.         }
  24.         set suite $htmlEventSuiteIDs($browserSig)
  25.  
  26.         AEBuild "'${browserSig}'" $suite {OURL} {----} "“$text”"
  27.         switchTo $name
  28. }
  29.  
  30.  
  31. proc expandURL {} {
  32.     set pos [getPos]
  33.     set beg [lineStart $pos]
  34.     if {[string length [set whe [search -s -n -f 1 -r 1 -i 1 -m 0 -l [nextLineStart $pos] {[a-zA-Z0-9]+://[a-zA-Z/._0-9~-]+} $beg]]]} {
  35.         if {($pos >= [lindex $whe 0]) && ($pos < [lindex $whe 1])} {
  36.             eval select $whe
  37.             return $whe
  38.         }
  39.     }
  40. }
  41.